home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue25 / webcomm / HTSHOPC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-07-29  |  9.2 KB  |  300 lines
  1. unit HtShopC;
  2.  
  3. //This is an example unit that was inherited from
  4. //TutParentForm through File|New|<Project>|TutParentForm
  5. //For inheritance to work, your uses clause must include
  6. //the units to be inherited from.
  7.  
  8. // Original code was provided by HREF Tools Corporation, Inc.
  9. // http://www.href.com
  10.  
  11. // Amendments (mainly the WebCreditCard1Execute event)
  12. // by P J Hyde, South Pacific Information Services Ltd
  13. // http://www.spis.co.nz
  14.  
  15. interface
  16.  
  17. uses
  18.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  19.   UTPANFRM, ExtCtrls, StdCtrls, TpLabel, Toolbar, WebMail, WebSock,
  20.   DBTables, DB, WdbSorce, UpdateOk, tpAction, WebTypes, WebIniFL, WebLink,
  21.   WdbLink, WdbScan, WdbGrid, ebutton, TpMemo, WebMemo, DBCtrls, Buttons,
  22.   Grids, DBGrids, ComCtrls, tpStatus, WebCCard;
  23.  
  24. type
  25.   TfmShopPanel = class(TutParentForm)
  26.     ToolBar: TtpToolBar;
  27.     PageControl1: TPageControl;
  28.     TabSheet3: TTabSheet;
  29.     Image1: TImage;
  30.     Label1: TLabel;
  31.     Label2: TLabel;
  32.     Label3: TLabel;
  33.     TabSheet1: TTabSheet;
  34.     DBGrid1: TDBGrid;
  35.     DBNavigator1: TDBNavigator;
  36.     WebDataGrid1: TWebDataGrid;
  37.     WebActionOrderList: TWebAction;
  38.     WebActionPostLit: TWebAction;
  39.     WebDataSource1: TWebDataSource;
  40.     DataSource1: TDataSource;
  41.     Table1: TTable;
  42.     Table1PartNo: TFloatField;
  43.     Table1VendorNo: TFloatField;
  44.     Table1Description: TStringField;
  45.     Table1OnHand: TFloatField;
  46.     Table1OnOrder: TFloatField;
  47.     Table1Cost: TCurrencyField;
  48.     Table1ListPrice: TCurrencyField;
  49.     Table1Qty: TSmallintField;
  50.     WebActionMailer: TWebAction;
  51.     tpStatusBar1: TtpStatusBar;
  52.     tpToolButton1: TtpToolButton;
  53.     tsEConfig: TTabSheet;
  54.     Label4: TLabel;
  55.     EditEMailFrom: TEdit;
  56.     EditEMailTo: TEdit;
  57.     Label5: TLabel;
  58.     EditMailhost: TEdit;
  59.     Label6: TLabel;
  60.     Label7: TLabel;
  61.     Label8: TLabel;
  62.     EditSubject: TEdit;
  63.     Label9: TLabel;
  64.     EditMailPort: TEdit;
  65.     WebCreditCard1: TWebCreditCard;
  66.     procedure Table1QtyGetText(Sender: TField; var Text: string;
  67.       DisplayText: Boolean);
  68.     procedure WebActionPostLitExecute(Sender: TObject);
  69.     procedure WebActionOrderListExecute(Sender: TObject);
  70.     procedure WebActionMailerExecute(Sender: TObject);
  71.     procedure tpToolButton1Click(Sender: TObject);
  72.     procedure WebCreditCard1Execute(Sender: TObject);
  73.   private
  74.     { Private declarations }
  75.     procedure getOrderList( sList: TStringList );
  76.     procedure ConfigEMail;
  77.   public
  78.     { Public declarations }
  79.     function Init: Boolean; override;
  80.   end;
  81.  
  82. var
  83.   fmShopPanel: TfmShopPanel;
  84.  
  85. implementation
  86.  
  87. {$R *.DFM}
  88.  
  89. uses
  90.   WebApp, AppUtil, utSpltfm, ucString, whMail;
  91.  
  92. //------------------------------------------------------------------------------
  93.  
  94. function TfmShopPanel.Init:Boolean;
  95. begin
  96.   Result:= inherited Init;
  97.   if not result then
  98.     exit;
  99.   //
  100.   fmWebMail.webmail.subject:='';   // init so that we know to config later.
  101.   //
  102.   {Other required settings:
  103.   twebdatagrid
  104.     datascanoptions        all set to true, except refresh and checkboxes
  105.     buttonsWhere           above
  106.     controlsWhere          none
  107.  
  108.   twebdatasource
  109.     maxOpenDataSets        1 (no cloning)
  110.     displaySets            defined in .ini file
  111.  
  112.   TTable
  113.     add fields using Delphi field editor
  114.     add calculated field called Qty, type integer
  115.   }
  116. end;
  117.  
  118. //------------------------------------------------------------------------------
  119. //------------------------------------------------------------------------------
  120.  
  121. procedure TfmShopPanel.ConfigEMail;
  122. begin
  123.   {configure email based on values on form. These are saved to the
  124.    href.ini file by the Restorer component.}
  125.   // e-mail settings -- please change to use your own defaults!
  126.   if EditEMailFrom.text='' then EditEMailFrom.text:='someone@theweb.com';
  127.   if EditEMailTo.text=''   then EditEMailTo.text:='info@href.com';
  128.   if EditMailHost.text=''  then EditMailHost.text:='mail.href.com';
  129.   if EditMailPort.text=''  then EditMailPort.text:='25';
  130.   if EditSubject.text=''   then EditSubject.text:='** Shop1 Sale';
  131.   //
  132.   with fmWebMail.webmail do begin
  133.     Sender.EMail:=EditEmailFrom.text;
  134.     MailTo.clear;
  135.     MailTo.add(editEMailTo.text);
  136.     MailHost.hostname:=EditMailhost.text;
  137.     MailHost.port:=StrToIntDef(EditMailport.text,25);
  138.     Subject:=EditSubject.text;
  139.     end;
  140. end;
  141.  
  142. { ------------------------------------------------------------------------- }
  143.  
  144. { To see what webhub is doing with your data, add %=chDebugInfo=% to the
  145.   bottom of the homepage and/or confirm pages.  That will display some
  146.   key arrays: webserver.dbFields, webserver.FormLiterals and websession.Literals.
  147.  
  148.   The data entered by the surfer into the webdatagrid is posted to the
  149.   dbFields array.  We need to jump in and copy that to the Literals array,
  150.   because dbFields is cleared at the end of the page.  Since we don't have
  151.   a real table to post to, we are using the Literals array as temporary
  152.   storage.  (Yes, you could add a temporary order table and post Qty there.)
  153. }
  154. procedure TfmShopPanel.WebActionPostLitExecute(Sender: TObject);
  155. var
  156.   a1,a2:string;
  157.   i:integer;
  158. begin
  159.   //WebDataSource1.Qty@1316=35
  160.   with TWebAction(Sender).WebApp do begin
  161.     for i:=0 to pred(WebServer.dbFields.count) do begin
  162.       SplitString(WebServer.dbFields[i],'=',a1,a2);
  163.       if a2<>'' then
  164.         Literal[a1]:=a2;   {post single entry to Literals array}
  165.       end;
  166.     end;
  167. end;
  168.  
  169. { ------------------------------------------------------------------------- }
  170.  
  171. { Illusion central:
  172.   Make the table act multi-surfer by defining the calculated field as equal to
  173.   the current surfer's Literals.}
  174. procedure TfmShopPanel.Table1QtyGetText(Sender: TField; var Text: string;
  175.   DisplayText: Boolean);
  176. begin
  177.   Text:=getWebApp.Literal['webdatasource1.Qty@'+
  178.     Sender.DataSet.FieldByName('PartNo').asString];
  179. end;
  180.  
  181.  
  182. { ------------------------------------------------------------------------- }
  183. { ------------------------------------------------------------------------- }
  184.  
  185. {Fill a stringlist with the current order.
  186.  Loop thru the Literals[] array looking for items with @ which come from the
  187.  data entry session.}
  188. procedure TfmShopPanel.getOrderList( sList: TStringList );
  189. var
  190.   a1,a2:string;
  191.   i:integer;
  192. begin
  193.   slist.clear;
  194.   with getWebApp.WebSession do begin
  195.     for i:=0 to pred(Literals.count) do begin
  196.       a1:=LeftOfEqual(Literals[i]);
  197.       if pos( '@', a1 ) > 0 then begin
  198.         //WebDataSource1.Qty@1316=35
  199.         SplitString(Literals[i],'=',a1,a2);  // SplitString is in the ucString unit
  200.         slist.add( 'Qty ' + a2 + ' of Product #' + RightOf( '@', a1 ));
  201.         end;
  202.       end;
  203.     end;
  204. end;
  205.  
  206.  
  207. { ------------------------------------------------------------------------- }
  208.  
  209. {this is one way to echo the current order.}
  210. procedure TfmShopPanel.WebActionOrderListExecute(Sender: TObject);
  211. var
  212.   sList:TStringList;
  213. begin
  214.   sList:=nil;
  215.   try
  216.     sList:=TStringList.create;
  217.     getOrderList(slist);
  218.     //send out the order, with a <BR> at end of each line
  219.     TWebAction(Sender).WebApp.WebOutput.SendStringListBR(slist);
  220.   finally
  221.     slist.free;
  222.     end;
  223. end;
  224.  
  225. { ------------------------------------------------------------------------- }
  226.  
  227. { Prepare and send mail message.}
  228. procedure TfmShopPanel.WebActionMailerExecute(Sender: TObject);
  229. var
  230.   sList:TStringList;
  231. begin
  232.   with TWebAction(Sender).WebApp, fmWebMail.webmail do begin
  233.     if subject='' then
  234.       configEMail;
  235.     //
  236.     Sender.Name:=Literal['CustFullName'];
  237.     // fill in the message (Lines property)
  238.     Lines.clear;
  239. (* original HREF code
  240.     Lines.add( 'CUSTOMER:' );
  241.     Lines.add( Literal['CustFullName'] );
  242.     Lines.add( Literal['CustCity'] );
  243.   replaced by PH with:
  244. *)
  245.     Lines.addStrings(Webserver.FormLiterals); { get it all in as var=value lines }
  246.  
  247.     Lines.add( '' );
  248.     Lines.add( 'ORDER:' );
  249.     sList:=nil;
  250.     try
  251.       sList:=TStringList.create;
  252.       getOrderList(slist);
  253.       Lines.AddStrings(slist);
  254.     finally
  255.       slist.free;
  256.       end;
  257.     execute;  {send the message}
  258.     end;
  259. end;
  260.  
  261. { ------------------------------------------------------------------------- }
  262.  
  263. { fun with tool buttons...}
  264.  
  265. procedure TfmShopPanel.tpToolButton1Click(Sender: TObject);
  266. begin
  267.   with DBGrid1 do
  268.     if DataSource=nil then begin
  269.       DataSource:=DataSource1;
  270.       DbNavigator1.DataSource:=DataSource1;
  271.       end
  272.     else begin
  273.       DataSource:=nil;
  274.       DbNavigator1.DataSource:=nil;
  275.       end
  276. end;
  277.  
  278.  
  279. procedure TfmShopPanel.WebCreditCard1Execute(Sender: TObject);
  280. begin
  281.   inherited;
  282.   with WebCreditCard1,WebCreditCard1.WebApp do
  283.   begin
  284.     if CompareText(Command,'CLEAR')=0 then exit;{ No check if clearing }
  285. (*
  286.     CardNumber := Literal['CardNumber'];        { Get surferÆs form input }
  287.     ExpirationDate := Literal['ExpirationDate'];
  288. *)
  289.     if (not Accept) or                          { Bad CC number/date }
  290.          (Literal['CardHolderName']='') then    { Blank name }
  291.     begin
  292.       Literal['CardProblem']:='Yes';            { Flag the problem }
  293.       WebOutput.send('%=Bounce|confirm=%');     { Bounce back to card entry form}
  294.     end else
  295.       Literal['CardProblem']:='';               { Clear any prior flag }
  296.   end;
  297. end;
  298.  
  299. end.
  300.